home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / imagelib.000 / tmulti.pas < prev    next >
Pascal/Delphi Source File  |  1996-04-08  |  26KB  |  889 lines
  1. {Copyright 1995 by
  2.  Kevin Adams, 74742,1444
  3.  Jan Dekkers, 72130,353
  4.  
  5. No part of this Unit may be copied in any way.
  6. However, you may derive other objects from
  7. TMultiImage.
  8.  
  9. Part of Imagelib VCL/DLL Library.
  10.  
  11. Written by Jan Dekkers and Kevin Adams}
  12.  
  13.  
  14. unit TMulti;
  15.  
  16. interface
  17.  
  18. uses
  19.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms,
  20.   Controls, Extctrls, StdCtrls, DLL22LIN, Menus, Mask, Buttons, SetSrMsg,
  21.   printers;
  22.  
  23.  
  24.  
  25. type
  26.   TMultiImage = class(TCustomControl)
  27.   private
  28.     FPicture            : TPicture;
  29.     FAutoSize           : Boolean;
  30.     FBorderStyle        : TBorderStyle;
  31.     FStretch            : Boolean;
  32.     FCenter             : Boolean;
  33.     FReserved           : Byte;
  34.     FFilename           : TFileName;
  35.     Fdither             : byte;
  36.     FResolution         : byte;
  37.     FSaveQuality        : byte;
  38.     FSaveSmooth         : byte;
  39.     FSaveFileName       : TFileName;
  40.     Temps               : TFileName;
  41.     BitMsg              : TBitmap;
  42.     SMessageLeft        : Integer;
  43.     SMessageRight       : Integer;
  44.     SMessageTop         : Integer;
  45.     ScreenWd            : Integer;
  46.     ScreenHt            : Integer;
  47.     BitWidth            : Integer;
  48.     DelayCounter        : LongInt;
  49.     function GetCanvas: TCanvas;
  50.     procedure PictureChanged(Sender: TObject);
  51.     procedure SetAutoSize(Value: Boolean);
  52.     procedure SetCenter(Value: Boolean);
  53.     procedure SetPicture(Value: TPicture);
  54.     procedure SetStretch(Value: Boolean);
  55.     procedure SetBorderStyle(Value: TBorderStyle);
  56.     procedure WMCut(var Message: TMessage); message WM_CUT;
  57.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  58.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  59.   protected
  60.     function GetPalette: HPALETTE; override;
  61.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  62.     procedure KeyPress(var Key: Char); override;
  63.     procedure CreateParams(var Params: TCreateParams); override;
  64.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  65.     procedure PrintBitMap(X, Y, pWidth, pHeight: Integer);
  66.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  67.     procedure LoadMessageFromFile(MessageName : TFileName);
  68.     Function Delay(Ms : Integer) : boolean;
  69.   public
  70.     BFiletype           :  String;
  71.     Bwidth              :  Integer;
  72.     BHeight             :  Integer;
  73.     Bbitspixel          :  Integer;
  74.     Bplanes             :  Integer;
  75.     Bnumcolors          :  Integer;
  76.     BSize               :  Longint;
  77.     Bcompression        :  String;
  78.     MessageRunning      :  Boolean;
  79.     MsgText             :  String;
  80.     MsgFont             :  TFont;
  81.     MsgBkGrnd           :  TColor;
  82.     MsgSpeed            :  Integer;
  83.     constructor Create(AOwner: TComponent); override;
  84.     destructor Destroy; override;
  85.     procedure CopyToClipboard;
  86.     procedure CutToClipboard;
  87.     procedure PasteFromClipboard;
  88.     property Canvas: TCanvas read GetCanvas;
  89.     function GetMultiBitmap : String;
  90.     Procedure WriteMultiName(Name : String);
  91.     procedure Paint; override;
  92.     function GetSmooth : Byte;
  93.     procedure SetSmooth(smooth : Byte);
  94.     function GetQuality : Byte;
  95.     procedure SetQuality(Quality : Byte);
  96.     function GetDither : Byte;
  97.     procedure SetDither(dith : Byte);
  98.     function GetRes : Byte;
  99.     procedure SetRes(res : Byte);
  100.     function GetSaveFileName : TFilename;
  101.     procedure SetSaveFileName(fn : TFilename);
  102.     procedure SaveAsJpg(FN : TFileName);
  103.     procedure SaveAsBMP(FN : TFileName);
  104.     function GetInfoAndType(filename : TFilename) : Boolean;
  105.     {scrolling message stuff}
  106.     Procedure Trigger;
  107.         procedure CreateMessage(MessagePath : String; AutoLoad : Boolean);
  108.     procedure SaveCurrentMessage(MessageName : TFileName);
  109.     procedure NewMessage;
  110.     Procedure FreeMsg;
  111.     {printing}
  112.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  113.   published
  114.     property Align;
  115.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  116.     property Center: Boolean read FCenter write SetCenter default False;
  117.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
  118.     property DragCursor;
  119.     property DragMode;
  120.     property Enabled;
  121.     property JPegDither : Byte read GetDither write SetDither;
  122.     property JPegResolution : Byte read GetRes write SetRes;
  123.     property Picture: TPicture read FPicture write SetPicture;
  124.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  125.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  126.     property DefSaveFileName : TFileName read GetSaveFileName write SetSaveFileName;
  127.     property ImageName  : String read GetMultiBitmap write WriteMultiName;
  128.     property ParentShowHint;
  129.     property PopupMenu;
  130.     property ShowHint;
  131.     property Stretch: Boolean read FStretch write SetStretch default False;
  132.     property Visible;
  133.     property OnClick;
  134.     property OnDblClick;
  135.     property OnDragDrop;
  136.     property OnDragOver;
  137.     property OnEndDrag;
  138.     property OnMouseDown;
  139.     property OnMouseMove;
  140.     property OnMouseUp;
  141.   end;
  142.  
  143.  
  144. var
  145.  TMultiImageCallBack   : TCallBackFunction;
  146.  
  147.  {------------------------------------------------------------------------}
  148.  
  149. implementation
  150.   uses Consts, Clipbrd, Dialogs, ToolHelp;
  151.  
  152. {------------------------------------------------------------------------
  153.  TMultiImage.
  154. ------------------------------------------------------------------------}
  155.  
  156.  
  157. constructor TMultiImage.Create(AOwner: TComponent);
  158. begin
  159.   inherited Create(AOwner);
  160.   FPicture := TPicture.Create;
  161.   FPicture.OnChange := PictureChanged;
  162.   FFilename:='';
  163.   Fdither:=4;
  164.   FResolution:=8;
  165.   FSaveQuality:=25;
  166.   FSaveSmooth:=0;
  167.   FBorderStyle := bsNone;
  168.   Picture.Graphic := nil;
  169.   Height := 105;
  170.   Width := 105;
  171.   MsgFont:=TFont.Create;
  172.   BitMsg := TBitmap.Create;
  173.   MessageRunning:=False;
  174.   SetupMsg:=Nil;
  175.   DelayCounter:=0;
  176.  end;
  177. {------------------------------------------------------------------------}
  178.  
  179.  
  180. destructor TMultiImage.Destroy;
  181. begin
  182.   FPicture.Free;
  183.   MsgFont.Free;
  184.   BitMsg.Free;
  185.   inherited Destroy;
  186. end;
  187. {------------------------------------------------------------------------}
  188.  
  189. function TMultiImage.GetPalette: HPALETTE;
  190. begin
  191.   Result := 0;
  192.   if FPicture.Graphic is TBitmap then
  193.     Result := TBitmap(FPicture.Graphic).Palette;
  194. end;
  195. {------------------------------------------------------------------------}
  196.  
  197. procedure TMultiImage.SetBorderStyle(Value: TBorderStyle);
  198. begin
  199.   if FBorderStyle <> Value then
  200.   begin
  201.     FBorderStyle := Value;
  202.     RecreateWnd;
  203.   end;
  204. end;
  205. {------------------------------------------------------------------------}
  206.  
  207. procedure TMultiImage.CreateParams(var Params: TCreateParams);
  208. begin
  209.   inherited CreateParams(Params);
  210.   if FBorderStyle = bsSingle then
  211.     Params.Style := Params.Style or WS_BORDER;
  212. end;
  213. {------------------------------------------------------------------------}
  214.  
  215. procedure TMultiImage.Paint;
  216. var
  217.   Dest : TRect;
  218. begin
  219.   if csDesigning in ComponentState then
  220.     with inherited Canvas do
  221.     begin
  222.       Pen.Style := psDash;
  223.       Brush.Style := bsClear;
  224.       Rectangle(0, 0, Width, Height);
  225.     end;
  226.   if Stretch then
  227.     Dest := ClientRect
  228.   else if Center then
  229.     Dest := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
  230.       Picture.Width, Picture.Height)
  231.   else
  232.     Dest := Rect(0, 0, Picture.Width, Picture.Height);
  233.   with inherited Canvas do
  234.     StretchDraw(Dest, Picture.Graphic);
  235.  
  236.   if (MessageRunning) and (Picture = nil) then FreeMsg;
  237. end;
  238.  
  239. {------------------------------------------------------------------------}
  240.  
  241. function TMultiImage.GetCanvas: TCanvas;
  242. var
  243.   Bitmap: TBitmap;
  244. begin
  245.   if Picture.Graphic = nil then
  246.   begin
  247.     Bitmap := TBitmap.Create;
  248.     try
  249.       Bitmap.Width := Width;
  250.       Bitmap.Height := Height;
  251.       Picture.Graphic := Bitmap;
  252.     finally
  253.       Bitmap.Free;
  254.     end;
  255.   end;
  256.   if Picture.Graphic is TBitmap then
  257.     Result := TBitmap(Picture.Graphic).Canvas
  258.   else
  259.     raise EInvalidOperation.Create(LoadStr(SImageCanvasNeedsBitmap));
  260. end;
  261. {------------------------------------------------------------------------}
  262.  
  263. procedure TMultiImage.SetAutoSize(Value: Boolean);
  264. begin
  265.   FAutoSize := Value;
  266.   PictureChanged(Self);
  267. end;
  268. {------------------------------------------------------------------------}
  269.  
  270. procedure TMultiImage.SetCenter(Value: Boolean);
  271. begin
  272.   if FCenter <> Value then
  273.   begin
  274.     FCenter := Value;
  275.     Invalidate;
  276.   end;
  277. end;
  278. {------------------------------------------------------------------------}
  279.  
  280. procedure TMultiImage.SetPicture(Value: TPicture);
  281. begin
  282.   FPicture.Assign(Value);
  283. end;
  284. {------------------------------------------------------------------------}
  285.  
  286. procedure TMultiImage.SetStretch(Value: Boolean);
  287. begin
  288.   FStretch := Value;
  289.   Invalidate;
  290. end;
  291. {------------------------------------------------------------------------}
  292.  
  293. procedure TMultiImage.PictureChanged(Sender: TObject);
  294. begin
  295.   if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
  296.     SetBounds(Left, Top, Picture.Width, Picture.Height);
  297.   if (Picture.Graphic is TBitmap) and (Picture.Width = Width) and
  298.     (Picture.Height = Height) then
  299.     ControlStyle := ControlStyle + [csOpaque] else
  300.     ControlStyle := ControlStyle - [csOpaque];
  301.   Invalidate;
  302. end;
  303. {------------------------------------------------------------------------}
  304.  
  305. function TMultiImage.GetDither : Byte;
  306. begin
  307.   GetDither:=Fdither
  308. end;
  309. {------------------------------------------------------------------------}
  310.  
  311. procedure TMultiImage.SetDither(dith : Byte);
  312. begin
  313.   Fdither:=4;
  314.   case dith of
  315.             0..4 :Fdither:=dith;
  316.   end;
  317. end;
  318. {------------------------------------------------------------------------}
  319.  
  320. function TMultiImage.GetRes : Byte;
  321. begin
  322.   GetRes:=FResolution;
  323. end;
  324. {------------------------------------------------------------------------}
  325.  
  326.  
  327. procedure TMultiImage.SetRes(res : Byte);
  328. begin
  329.   FResolution:=8;
  330.   case res of
  331.             4 :FResolution:=res;
  332.             8 :FResolution:=res;
  333.             24 :FResolution:=res;
  334.   end;
  335. end;
  336. {------------------------------------------------------------------------}
  337.  
  338. Procedure TMultiImage.WriteMultiName(Name : String);
  339. begin
  340.   FFilename:=Name;
  341.   GetMultiBitmap;
  342. end;
  343. {------------------------------------------------------------------------}
  344.  
  345.  
  346. function TMultiImage.GetMultiBitmap :  String;
  347. var    bitmap     : TBitMap;
  348.        Pextension : string[4];
  349.        OnExcept   : Boolean;
  350.        f          : file of byte;
  351. label  BreakIt;
  352.  
  353. begin
  354.   OnExcept:=False;
  355.   if not FileExists(FFilename) then begin
  356.      Picture.Graphic := nil;
  357.      temps:='file not found';
  358.      GetMultiBitmap:=temps;
  359.      exit;
  360.   end;
  361.  
  362.   if FResolution <> 4 then if FResolution <> 8 then if FResolution <> 24 then
  363.    FResolution:=8;
  364.  
  365.   if (FDither < 0) or (FDither > 4) then FDither:=4;
  366.  
  367.   Pextension:=UpperCase(ExtractFileExt(FFilename));
  368.  
  369.   if (Pextension =  '.WMF') or (Pextension =  '.ICO') then begin
  370.     FreeMsg;
  371.     Picture.LoadFromFile(FFilename);
  372.     Temps:='Non JPeg, BMP, GIF or PCX Image';
  373.     GetMultiBitmap:=Temps;
  374.     GetInfoAndType(FFileName);
  375.     exit;
  376.   end;
  377.  
  378.  if (UpperCase(FFilename) = temps) and (Picture.Bitmap <> nil) then
  379.    Goto BreakIt;
  380.  
  381.  if Pextension = '.SCM' then begin
  382.     try
  383.      LoadMessageFromFile(FFileName);
  384.     except
  385.      Picture.Graphic := nil;
  386.      OnExcept:=True;
  387.     end;
  388.     if OnExcept then Goto BreakIt;
  389.     GetInfoAndType(FFileName);
  390.  end;
  391.  
  392.  if Pextension = '.BMP' then begin
  393.     try
  394.      FreeMsg;
  395.      Bitmap := TBitmap.Create;
  396.      if not bmpfile(FFileName, Bitmap, TMultiImageCallBack) then
  397.        MessageDlg('Reading bmp file failed', mtInformation, [mbOk], 0);
  398.     except
  399.      Picture.Graphic := nil;
  400.      Bitmap.Free;
  401.      OnExcept:=True;
  402.     end;
  403.      if OnExcept then Goto BreakIt;
  404.      Picture.Graphic:=Bitmap;
  405.      Bitmap.Free;
  406.      GetInfoAndType(FFileName);
  407.  end;
  408.  
  409.  if Pextension = '.GIF' then begin
  410.     try
  411.      FreeMsg;
  412.      Bitmap := TBitmap.Create;
  413.      if not Giffile(FFileName, Bitmap, TMultiImageCallBack) then
  414.        MessageDlg('Reading gif file failed', mtInformation, [mbOk], 0);
  415.     except
  416.      Picture.Graphic := nil;
  417.      Bitmap.Free;
  418.      OnExcept:=True;
  419.     end;
  420.      if OnExcept then Goto BreakIt;
  421.      Picture.Graphic:=Bitmap;
  422.      Bitmap.Free;
  423.      GetInfoAndType(FFileName);
  424.  end;
  425.  
  426.  if Pextension = '.PCX' then begin
  427.     try
  428.      FreeMsg;
  429.      Bitmap := TBitmap.Create;
  430.      if not PCXfile(FFileName, Bitmap, TMultiImageCallBack) then
  431.        MessageDlg('Reading pcx file failed', mtInformation, [mbOk], 0);
  432.     except
  433.      Picture.Graphic := nil;
  434.      Bitmap.Free;
  435.      OnExcept:=True;
  436.     end;
  437.      if OnExcept then Goto BreakIt;
  438.      Picture.Graphic:=Bitmap;
  439.      Bitmap.Free;
  440.      GetInfoAndType(FFileName);
  441.  end;
  442.  
  443.  if Pextension = '.JPG' then begin
  444.     try
  445.      FreeMsg;
  446.      Bitmap := TBitmap.Create;
  447.      if not jpgfile(FFilename, FResolution, Fdither, Bitmap, TMultiImageCallBack) then
  448.        MessageDlg('Reading jpg file failed', mtInformation, [mbOk], 0);
  449.     except
  450.      Picture.Graphic := nil;
  451.      Bitmap.Free;
  452.      OnExcept:=True;
  453.     end;
  454.      if OnExcept then Goto BreakIt;
  455.      Picture.Graphic:=Bitmap;
  456.      Bitmap.Free;
  457.      GetInfoAndType(FFileName);
  458.  end;
  459.  
  460.  BreakIt:
  461.  Temps:=UpperCase(FFilename);
  462.  GetMultiBitmap:=Temps;
  463. end;
  464. {------------------------------------------------------------------------}
  465.  
  466. function TMultiImage.GetSmooth : Byte;
  467. begin
  468.   GetSmooth:=FSaveSmooth;
  469. end;
  470. {------------------------------------------------------------------------}
  471.  
  472. procedure TMultiImage.SetSmooth(Smooth : Byte);
  473. begin
  474.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  475.    FSaveSmooth:=Smooth;
  476. end;
  477. {------------------------------------------------------------------------}
  478.  
  479. function TMultiImage.GetQuality : Byte;
  480. begin
  481.   GetQuality:=FSaveQuality;
  482. end;
  483. {------------------------------------------------------------------------}
  484.  
  485. procedure TMultiImage.SetQuality(Quality : Byte);
  486. begin
  487.   if (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  488.    FSaveQuality:=Quality;
  489. end;
  490. {------------------------------------------------------------------------}
  491.  
  492. function TMultiImage.GetSaveFileName : TFilename;
  493. begin
  494.   GetSaveFileName:=FSaveFileName;
  495. end;
  496. {------------------------------------------------------------------------}
  497.  
  498. procedure TMultiImage.SetSaveFileName(fn : TFilename);
  499. begin
  500.  if fn <> '' then
  501.    FSaveFileName:=fn
  502.  else
  503.    FSaveFileName:='';
  504. end;
  505.  
  506.  
  507. {------------------------------------------------------------------------}
  508. procedure TMultiImage.SaveAsBMP(FN : TFileName);
  509. begin
  510.    if fn <> '' then FSaveFileName:=fn;
  511.   try
  512.     if not putbmpfile(FSaveFileName, picture.Bitmap, TMultiImageCallBack) then
  513.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  514.   except
  515.  
  516.   end;
  517. end;
  518.  
  519. {------------------------------------------------------------------------}
  520.  
  521. procedure TMultiImage.SaveAsJpg(FN : TFileName);
  522. begin
  523.    if fn <> '' then FSaveFileName:=fn;
  524.   try
  525.    if not putjpgfile(FSaveFileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TMultiImageCallBack) then
  526.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  527.   except
  528.  
  529.   end;
  530. end;
  531.  
  532. {------------------------------------------------------------------------}
  533. function TMultiImage.GetInfoAndType(filename : TFilename) : Boolean;
  534. var
  535.   Pextension : string[4];
  536.   f          : file of byte;
  537. begin
  538.  Pextension:=UpperCase(ExtractFileExt(Filename));
  539.  
  540.  if (Pextension =  '.WMF') or (Pextension =  '.ICO') or (Pextension =  '.SCM') then begin
  541.  
  542.    if fileexists(Filename) then begin
  543.     Delete(Pextension,1,1);
  544.     BFiletype           := Pextension;
  545.     Bwidth              := Picture.width;
  546.     BHeight             := Picture.Height;
  547.     Bbitspixel          := 0;
  548.     Bplanes             := 0;
  549.     Bnumcolors          := 0;
  550.     Bcompression        := Pextension;
  551.     AssignFile(f, FFileName);
  552.     Reset(f);
  553.     Bsize := FileSize(f);
  554.     CloseFile(f);
  555.     GetInfoAndType:=true;
  556.     exit;
  557.    end else
  558.  
  559.    begin
  560.     BFiletype           := 'ERR';
  561.     Bwidth              := -1;
  562.     BHeight             := -1;
  563.     Bbitspixel          := -1;
  564.     Bplanes             := -1;
  565.     Bnumcolors          := -1;
  566.     Bcompression        := 'ERR';
  567.     Bsize               := -1;
  568.     GetInfoAndType      := false;
  569.     exit;
  570.    end;
  571.   end;
  572.  
  573.   GetInfoAndType:=GetFileInfo(filename,
  574.                               BFileType,
  575.                               Bwidth,
  576.                               BHeight,
  577.                               Bbitspixel,
  578.                               Bplanes,
  579.                               Bnumcolors,
  580.                               Bcompression);
  581.    AssignFile(f, FileName);
  582.    Reset(f);
  583.    Bsize := FileSize(f);
  584.    CloseFile(f);
  585.  end;
  586. {------------------------------------------------------------------------
  587.  ClipBoard stuff
  588. ------------------------------------------------------------------------}
  589.  
  590. procedure TMultiImage.WMCut(var Message: TMessage);
  591. begin
  592.   CutToClipboard;
  593. end;
  594. {------------------------------------------------------------------------}
  595.  
  596. procedure TMultiImage.WMCopy(var Message: TMessage);
  597. begin
  598.   CopyToClipboard;
  599. end;
  600. {------------------------------------------------------------------------}
  601.  
  602. procedure TMultiImage.WMPaste(var Message: TMessage);
  603. begin
  604.   PasteFromClipboard;
  605. end;
  606. {------------------------------------------------------------------------}
  607.  
  608. procedure TMultiImage.CopyToClipboard;
  609. begin
  610.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  611. end;
  612. {------------------------------------------------------------------------}
  613.  
  614. procedure TMultiImage.CutToClipboard;
  615. begin
  616.   if Picture.Graphic <> nil then
  617.   begin
  618.     CopyToClipboard;
  619.     Picture.Graphic := nil;
  620.   end;
  621. end;
  622. {------------------------------------------------------------------------}
  623.  
  624. procedure TMultiImage.PasteFromClipboard;
  625. begin
  626.   if Clipboard.HasFormat(CF_PICTURE) then begin
  627.     MessageRunning:=False;
  628.     Picture.Assign(Clipboard);
  629.   end;
  630. end;
  631. {------------------------------------------------------------------------}
  632.  
  633. procedure TMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
  634. begin
  635.   inherited KeyDown(Key, Shift);
  636.   case Key of
  637.     VK_INSERT:
  638.       if ssShift in Shift then PasteFromClipBoard else
  639.         if ssCtrl in Shift then CopyToClipBoard;
  640.     VK_DELETE:
  641.       if ssShift in Shift then CutToClipBoard;
  642.   end;
  643. end;
  644. {------------------------------------------------------------------------}
  645.  
  646. procedure TMultiImage.KeyPress(var Key: Char);
  647. begin
  648.   inherited KeyPress(Key);
  649.   case Key of
  650.     ^X: CutToClipBoard;
  651.     ^C: CopyToClipBoard;
  652.     ^V: PasteFromClipBoard;
  653.   end;
  654. end;
  655. {------------------------------------------------------------------------
  656.  scrolling message stuff
  657. ------------------------------------------------------------------------}
  658.  
  659. procedure TMultiImage.LoadMessageFromFile(MessageName : TFileName);
  660. var
  661.   Msg      : TLabel;
  662. begin
  663.   Picture.Assign(nil);
  664.   ScreenWd:=Width;
  665.   ScreenHt:=Height;
  666.   Msg := TLabel.Create(Self);
  667.   readmessagefromfile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  668.   Refresh;
  669.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  670.   Msg.Parent :=Self;
  671.   Msg.Visible := False;
  672.   Msg.Font := MsgFont;
  673.   Msg.Caption := MsgText;
  674.   BitWidth:=Msg.Width;
  675.   SMessageLeft := ScreenWd;
  676.   SMessageRight := ScreenWd + Msg.Width;
  677.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  678.   BitMsg.Width := Msg.Width;
  679.   BitMsg.Height := Msg.Height;
  680.  
  681.   with Canvas do begin
  682.     Brush.Style := bsSolid;
  683.     Brush.Color:=MsgBkGrnd;
  684.     Rectangle(0, 0, Width, Height);
  685.   end;
  686.  
  687.   with BitMsg.Canvas do begin
  688.     Brush.Color := MsgBkGrnd;
  689.     Font := Msg.Font;
  690.     TextOut(0,0,Msg.Caption);
  691.   end;
  692.  
  693.    Msg.Free;
  694.    Msg := nil;
  695.    MessageRunning:=True;
  696. end;
  697. {------------------------------------------------------------------------}
  698.  
  699. procedure TMultiImage.NewMessage;
  700. var
  701.   Msg      : TLabel;
  702. begin
  703.   if MsgText = '' then exit;
  704.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  705.   Picture.Assign(nil);
  706.   ScreenWd:=Width;
  707.   ScreenHt:=Height;
  708.   Msg := TLabel.Create(Self);
  709.   Refresh;
  710.   Msg.Parent :=Self;
  711.   Msg.Visible := False;
  712.   Msg.Font := MsgFont;
  713.   Msg.Caption := MsgText;
  714.   BitWidth:=Msg.Width;
  715.   SMessageLeft := ScreenWd;
  716.   SMessageRight := ScreenWd + Msg.Width;
  717.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  718.   BitMsg.Width := Msg.Width;
  719.   BitMsg.Height := Msg.Height;
  720.  
  721.   with Canvas do begin
  722.     Brush.Style := bsSolid;
  723.     Brush.Color:=MsgBkGrnd;
  724.     Rectangle(0, 0, Width, Height);
  725.   end;
  726.  
  727.   with BitMsg.Canvas do begin
  728.     Brush.Color := MsgBkGrnd;
  729.     Font := Msg.Font;
  730.     TextOut(0,0,Msg.Caption);
  731.   end;
  732.  
  733.    Msg.Free;
  734.    Msg := nil;
  735.    MessageRunning:=True;
  736. end;
  737. {------------------------------------------------------------------------}
  738.  
  739. procedure TMultiImage.SaveCurrentMessage(MessageName : TFileName);
  740. begin
  741.   WriteMessageToFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  742. end;
  743. {------------------------------------------------------------------------}
  744.  
  745. procedure TMultiImage.CreateMessage(MessagePath : String; AutoLoad : Boolean);
  746. var
  747.  SaveDlg : TSaveDialog;
  748.  MsName  : TFilename;
  749. begin
  750.  Application.CreateForm(TSetupMsg, SetupMsg );
  751.  SetupMsg.ShowModal;
  752.  MsName:='';
  753.  if SetupMsg.ModalResult = mrOK then begin
  754.    SaveDlg :=TSaveDialog.Create(self);
  755.    SaveDlg.DefaultExt:='scm';
  756.    SaveDlg.Filter:='scrollmessage|*.scm';
  757.    SaveDlg.Options:=[ofOverwritePrompt];
  758.    SaveDlg.InitialDir:=MessagePath;
  759.    if SaveDlg.Execute then begin
  760.     MsName:=SaveDlg.Filename;
  761.     WriteMessageToFile(MsName, SetupMsg.MessageFont, SetupMsg.MessageSpeed,
  762.                        SetupMsg.MessageColor, SetupMsg.MessageMsg);
  763.    end;
  764.    SaveDlg.free;
  765.  end;
  766.  
  767.  SetupMsg.destroy;
  768.  SetupMsg:=Nil;
  769.  
  770.  if (AutoLoad) and (MsName <> '')  then
  771.    LoadMessageFromFile(MsName)
  772.  else
  773.    NewMessage;
  774. end;
  775. {------------------------------------------------------------------------}
  776.  
  777. Procedure TMultiImage.FreeMsg;
  778. Begin
  779.   Picture.Assign(nil);
  780.   MessageRunning:=False;
  781. end;
  782. {------------------------------------------------------------------------}
  783.  
  784. Function TMultiImage.Delay(Ms : Integer) : boolean;
  785. Begin
  786.  Inc(DelayCounter);
  787.  if DelayCounter > MS then begin
  788.     DelayCounter:=0;
  789.     Result:=true;
  790.  end else
  791.   Result:=false;
  792. end;
  793. {------------------------------------------------------------------------}
  794.  
  795. Procedure TMultiImage.MoveMsg(Var WinMsg : TMessage);
  796. Begin
  797.   if Not MessageRunning then exit;
  798.   if not Delay(MsgSpeed) then exit;
  799.   Dec(SMessageLeft,1);
  800.   Dec(SMessageRight,1);
  801.   if SMessageRight < 0 then begin
  802.     SMessageLeft := ScreenWd;
  803.     SMessageRight := SMessageLeft + BitWidth;
  804.   end;
  805.   Picture.Bitmap.Canvas.Draw(SMessageLeft,SMessageTop,BitMsg);
  806. end;
  807. {------------------------------------------------------------------------}
  808.  
  809. Procedure TMultiImage.Trigger;
  810. Begin
  811.   PostMessage(Handle, WM_Trigger, 0, 0);
  812.   if visible then
  813.    if SetupMsg <> nil then SetupMsg.Trigger;
  814. End;
  815.  
  816. {------------------------------------------------------------------------
  817. Printing Stuff
  818. ------------------------------------------------------------------------}
  819.  
  820. procedure TMultiImage.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  821. begin
  822.  if Picture.Graphic.Empty then exit;
  823.  
  824.  if (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  825.    PrintICOWMF(X, Y, pWidth, pHeight)
  826.  else
  827.    PrintBitMap(X, Y, pWidth, pHeight)
  828. end;
  829. {---------------------------------------------------------------------}
  830.  
  831. procedure TMultiImage.PrintBitMap(X, Y, pWidth, pHeight: Integer);
  832. var
  833.   Info     : PBitmapInfo;
  834.   InfoSize : Integer;
  835.   Image    : Pointer;
  836.   ImageSize: Longint;
  837. begin
  838.    if (pWidth < 1) or (pHeight < 1) then begin
  839.       pWidth:=Picture.Bitmap.Width;
  840.       pHeight:=Picture.Bitmap.Height;
  841.    end;
  842.  
  843.    Printer.Begindoc;
  844.  
  845.     with Picture.Bitmap do begin
  846.       GetDIBSizes(Handle, InfoSize, ImageSize);
  847.       Info := MemAlloc(InfoSize);
  848.       try
  849.         Image := MemAlloc(ImageSize);
  850.         try
  851.           GetDIB(Handle, Palette, Info^, Image^);
  852.           with Info^.bmiHeader do
  853.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  854.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  855.             DIB_RGB_COLORS, SRCCOPY)
  856.          finally
  857.           FreeMem(Image, ImageSize);
  858.          end;
  859.       finally
  860.        FreeMem(Info, InfoSize);
  861.       end;
  862.     end;
  863.     Printer.Enddoc;
  864.   end;
  865. {---------------------------------------------------------------------}
  866.  
  867. procedure TMultiImage.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  868. begin
  869.    if (pWidth < 1) or (pHeight < 1) then begin
  870.     pWidth:=Picture.Graphic.Width;
  871.     pHeight:=Picture.Graphic.Height;
  872.    end;
  873.  
  874.    Printer.Begindoc;
  875.  
  876.    Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  877.  
  878.    Printer.Enddoc;
  879. end;
  880. {------------------------------------------------------------------------
  881. end TMultiImage
  882. ------------------------------------------------------------------------}
  883.  
  884.  
  885. begin
  886.  TMultiImageCallBack:=nil;
  887. end.
  888.  
  889.